home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0920.ZIP / TEXTIO.ARC / TEXTIO.PAS
Encoding:
Pascal/Delphi Source File  |  1988-01-22  |  7.4 KB  |  284 lines
  1. {textio.pas -- demo of input/output "tricks" for turbo pascal }
  2. (*
  3.    demonstration of useful text i/o features with turbo pascal:
  4.      1. large text buffers for speedier handling when needed
  5.      2. complete seek function for text files
  6.      3. write formatted output to a string variable
  7.      4. read contents of a string variable as formatted input
  8.  
  9.    language:  turbo pascal macintosh "{, comments "
  10.          or:  turbo pascal 4.0 ibm.  "{. comments "
  11.  
  12.    by d.g.gilbert
  13.    dogStar software
  14.    po box 302, bloomington, in 47402
  15.    compuserve  71450,1570
  16. *)
  17.  
  18. PROGRAM turboTextIO;
  19. {$R-}   { Turn off range checking       }
  20. {$I-}   { Turn off I/O error checking   }
  21.  
  22. {.ibm} USES  DOS;
  23. (*{,mac} USES  memTypes, quickDraw, osIntf, toolIntf;*)
  24.  
  25. CONST
  26.       forOutput = true; forInput = false;
  27. TYPE
  28. (*        pointer = ^integer; {,mac} *)
  29.         chars   = PACKED ARRAY [0..maxint] OF char;
  30.         bufferPtr = ^chars;
  31.         procPtr   = pointer;
  32.  
  33.  
  34. {.turbo pascal ibm text file record}
  35.         tpFileRec = RECORD
  36.           handle   : word;
  37.           mode     : word;
  38.           fBufSize : word;
  39.           private  : word;
  40.           fBufPos  : word;
  41.           fBufEnd  : word;
  42.           fBuffer  : bufferPtr;
  43.           openFunc : procptr;
  44.           inOutFunc: procptr;
  45.           flushFunc: procptr;
  46.           closeFunc: procptr;
  47.           userdata : PACKED ARRAY[1..16] OF byte;
  48.           name     : PACKED ARRAY [0..79] OF char;
  49.           tbuffer  : PACKED ARRAY [0..127] OF char; { default buffer}
  50.           END;
  51. (*
  52. {, turbo pascal mac file record }
  53.       tpFileRec   = RECORD
  54.           fInpFlag: boolean;
  55.           fOutFlag: boolean;
  56.           fRefNum : integer;
  57.           fVrefNum: integer;
  58.           fBufSize: integer;
  59.           fBufPos : integer;
  60.           fBufEnd : integer;
  61.           fBuffer : bufferPtr;
  62.           fInOutProc: procPtr;
  63.           END;
  64. *)
  65.  
  66.  
  67.  
  68. FUNCTION openText( VAR f: text;
  69.          fname : STRING;
  70.          output: boolean;  {true if want a rewrite }
  71.          bufsize: integer
  72.          ): boolean;     { true if opened successfully }
  73.  
  74. VAR  abuf: pointer;
  75.      err: integer;
  76. BEGIN
  77.  
  78. {. ibm}
  79.     assign( f, fname);
  80.    { now change buf to the size we want}
  81.     WITH tpfilerec(f) DO BEGIN
  82.       getmem( abuf, bufsize);
  83.       fBuffer:= abuf;
  84.       fBufSize:= bufsize;
  85.       END;
  86.     IF output THEN rewrite( f) ELSE reset(f);
  87.     err:= ioresult;
  88.     IF err <> 0 THEN dispose(abuf); {forget it}
  89.     openText:= err = 0;
  90. (*
  91. {, mac}
  92.     IF output THEN rewrite( f, fname, bufsize)
  93.     ELSE reset( f, fname, bufsize);
  94.     openText:= ioresult = 0;
  95. *)
  96. END; {openText}
  97.  
  98. PROCEDURE closeText( VAR f: text);
  99. VAR  abuf: pointer;
  100. BEGIN
  101. {.ibm} abuf:= tpfilerec(f).fBuffer;
  102.        close(f);
  103. {.ibm} dispose(abuf);
  104. END;
  105.  
  106.  
  107. {.ibm}
  108. CONST strFileName = '$%#temp.tmp';
  109. CONST needStrFile: boolean = true; {1st time open tempFile }
  110. VAR   strFile    : text; {.ibm -- save file i/o information for strIO}
  111.  
  112. PROCEDURE openStrIO( VAR f: text; VAR s: STRING; out: boolean);
  113. { assign file input/output to string. }
  114. BEGIN
  115.  
  116. {.ibm}
  117.    IF needStrFile THEN BEGIN
  118.      assign(strFile, strFileName);
  119.      rewrite(strFile); {<< need this to fill in valid turbo proc ptrs}
  120.      tpfilerec(f):= tpfilerec(strFile);
  121.      close(strFile); erase(strFile);
  122.      tpfilerec(strfile):= tpfilerec(f);
  123.      needStrFile:= false;
  124.      END;
  125.    tpfilerec(f):= tpfilerec(strFile);
  126.    WITH tpFileRec(f) DO BEGIN
  127.      IF out THEN mode:= fmOutput ELSE mode:= fmInput;
  128.      END;
  129. (*
  130. {,mac}
  131.    WITH tpfilerec(f) DO BEGIN
  132.      fInpFlag:= NOT out;
  133.      fOutFlag:= out;
  134.      fRefNum:= 1; {dummy}
  135.      fVrefNum:= 1;
  136.      fInOutProc:= NIL;
  137.      END;
  138. *)
  139. {both}
  140.    WITH tpFileRec(f) DO BEGIN
  141.      fBuffer:= @s[1];
  142.      fBufSize:= 255; {assume it is full string}
  143.      IF out THEN fBufEnd:= fBufSize
  144.      ELSE fBufEnd:= length(s);
  145.      fBufPos:= 0;
  146.      END;
  147. END; {openStrIO}
  148.  
  149. PROCEDURE closeStrIO( VAR f: text; VAR s: STRING);
  150. { close stringiO: get length }
  151. VAR  err: integer;
  152. BEGIN
  153.    s[0]:= chr( tpFileRec(f).fBufPos);
  154. END; {closeStrIO}
  155.  
  156.  
  157. TYPE seekType = (seek_set, seek_cur, seek_end);
  158.  
  159. {.ibm version}
  160. PROCEDURE seekText( VAR f: text; offset: longInt;
  161.             seekFrom : seektype);
  162. { seek for textfiles }
  163. VAR
  164.    count: longint;
  165.    iseek: integer;
  166.    err  : integer;
  167.    uf   : FILE; {.ibm}
  168.  
  169.  
  170.   FUNCTION msDosSeek( fh:integer; index:longint; fromwhere:seekType):integer;
  171.   { move file pointer to byte index (hiIndx,lowIndx), respective to fromWhere }
  172.   TYPE  words = ARRAY [0..1] OF word;
  173.   VAR  reg : registers;
  174.   BEGIN
  175.     reg.ah:= $42; { move f^ }
  176.     reg.al:= ord(fromwhere);
  177.     reg.cx:= words(index)[1]; {hiindex}
  178.     reg.dx:= words(index)[0]; {lowIndex}
  179.     reg.bx := fh;
  180.     msdos(reg);
  181.     IF 0 = (reg.flags AND $01) THEN msdosSeek:= 0 ELSE msDosSeek:= reg.ax;
  182.   END; { msDosSeek }
  183.  
  184. BEGIN
  185. {.ibm}
  186.   WITH tpFileRec(f) DO
  187.    IF handle<0 THEN {nada - not a disk file}
  188.    ELSE BEGIN
  189.     IF mode = fmOutput THEN BEGIN
  190.      { flush buffer to disk if seek on output file}
  191.       move(f, uf, sizeof(f));    { need right file type for blockwrite}
  192.       fileRec(uf).recsize:= 1;
  193.       blockwrite( uf, fBuffer^, fBufPos, err);
  194.       fBufPos:= 0;
  195.       END
  196.     ELSE IF seekFrom = seek_cur THEN
  197.       offset:= offset - fBufEnd + fBufPos;
  198.     IF 0 = msdosSeek( handle, offset, seekFrom) THEN BEGIN
  199.       fBufPos:= 0; fBufEnd:= 0; {next read/write will fill buffer as needed}
  200.       END;
  201.    END;
  202. END; {seekText}
  203. (*******
  204. {, mac version }
  205. PROCEDURE seekText( VAR f: text; offset: longInt;
  206.             seekFrom : seektype);
  207. { seek for textfiles }
  208. VAR
  209.    count: longint;
  210.    iseek: integer;
  211.    err  : integer;
  212. BEGIN
  213.   CASE seekFrom OF
  214.     seek_set : iseek:= fsFromStart; {offset from 0}
  215.     seek_cur : iseek:= fsFromMark;
  216.     seek_end : iseek:= fsFromLEOF;
  217.     END;
  218.   WITH tpFileRec(f) DO
  219.    IF fRefNum=0 THEN {not a disk file}
  220.    ELSE BEGIN
  221.     IF fOutFlag THEN BEGIN { flush buffer to disk if seek on output file}
  222.       count:= fBufPos;
  223.       err:= fsWrite( fRefNum, count, ptr(fBuffer));
  224.       fBufPos:= 0;
  225.       END
  226.     ELSE IF seekFrom = seek_cur THEN
  227.       offset:= offset - fBufEnd + fBufPos;
  228.     IF 0 = setFpos( fRefNum, iseek, offset) THEN BEGIN
  229.       fBufEnd:= 0; fBufPos:= 0;
  230.       END;
  231.    END;
  232. END; {seekText}
  233. ***********)
  234.  
  235.  
  236.  
  237. { test }
  238. CONST
  239.      BUFSIZE = 32000; { a big text buffer}
  240. VAR
  241.      f: text;
  242.      s: STRING;
  243.      i: integer;
  244.      r: real;
  245.      b: boolean;
  246.      index: longint;
  247. BEGIN
  248.   writeln;
  249.   writeln('useful Turbo Pascal Text I/O features');
  250.   writeln('by d.g.gilbert, Dec87');
  251.   writeln;
  252.  
  253.   write('File to Open: '); readln( s);
  254.   IF openText( f, s, forInput, BUFSIZE) THEN BEGIN
  255.    REPEAT
  256.     write('Seek type 0)set, 1)current, 2)end : '); readln( i);
  257.     IF i IN [0..2] THEN BEGIN
  258.       write('Seek index: '); readln( index);
  259.       seekText( f, index, seekType(i));
  260.       readln( f, s); writeln('> ',s);
  261.       END;
  262.    UNTIL NOT (i IN [0..2]);
  263.    closeText( f);
  264.    END;
  265.  
  266.   writeln('Testing formatted output to a string');
  267.   i:= 99; r:= 12.34; b:= true;
  268.   openStrIO( f, s, forOutput);
  269.   writeln( f, i:10, r:10:3, b:5);
  270.   closeStrIO( f, s);
  271.   writeln('The formatted string is:');
  272.   writeln( s);
  273.  
  274.   i:= 0; r:= 0;
  275.   writeln('Testing string to formatted input');
  276.   openStrIO( f, s, forInput);
  277.   read( f, i, r);    {tp can't read booleans}
  278.   closeStrIO( f, s);
  279.   writeln('The read variables are:');
  280.   writeln( i:10, r:10:3);
  281.   write('Hit return...'); readln;
  282. END.
  283.  
  284.